home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / fixnum.t < prev    next >
Text File  |  1989-06-30  |  4KB  |  102 lines
  1. (herald fixnum (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define-constant *bits-per-fixnum* 30)
  27. (define-constant *u-bits-per-fixnum* (fx- *bits-per-fixnum* 1))
  28.  
  29. (define-constant most-negative-fixnum (fixnum-ashl (no-op 1) *u-bits-per-fixnum*))
  30. (define-constant most-positive-fixnum (fx- most-negative-fixnum 1))
  31.  
  32. (define-constant positive-sign-char #\+)
  33. (define-constant negative-sign-char #\-)
  34. (define-constant ratio-char         #\/)
  35.  
  36. (define-integrable (exponent-introducer? ch)
  37.   (or (char= ch #\e) (char= ch #\E)))
  38.  
  39. (define-integrable (sign-char? ch)
  40.   (or (char= ch positive-sign-char)
  41.       (char= ch negative-sign-char)))
  42.  
  43. ;;; Fixnum hackery
  44.  
  45. (define (fixnum-expt x y)
  46.   (labels (((real-fixnum-expt x y)
  47.             (do ((y y (fixnum-ashr y 1))
  48.                  (x x (fx* x x))
  49.                  (z 1 (if (fixnum-odd? y) (fx* z x) z)))
  50.                 ((fx<= y 0) z))))
  51.     (cond ((fx< y 0) (fixnum-negative-expt x y))
  52.           ((fx= y 0) 1)
  53.           (else (real-fixnum-expt x y)))))
  54.  
  55. (define (fixnum-bit? fx bit)
  56.   (let ((shifted (fixnum-ashr fx bit)))
  57.     (fxn= shifted (fixnum-ashl (fixnum-ashr shifted 1) 1))))
  58.  
  59.  
  60. (define (fixnum-bit-field fixnum start count)
  61.   (fx-and (fx-not (fx-ashl -1 count)) (fx-ashr fixnum start)))
  62.  
  63. ;;; chop off VAL high bits, OR field into target, move field to
  64. ;;; appropriate pos
  65.  
  66. (define (set-fixnum-bit-field fixnum start count val)
  67.   (let ((val (fixnum-bit-field val 0 count)))
  68.     (fx-ior (fx-ashl val start)
  69.             (fx-and (fx-ior (fx-not (fx-ashl -1 start))
  70.                             (fx-ashl -1 (fx+ start count)))
  71.                     fixnum))))
  72.  
  73. ;;; Aliases
  74.  
  75. (define fx-odd?   fixnum-odd?)
  76. (define fx-even?  fixnum-even?)
  77. (define fx-length fixnum-length)
  78. (define fx-expt   fixnum-expt)
  79. (define fx-bit?   fixnum-bit?)
  80.  
  81. (define handle-fixnum
  82.   (object nil
  83.     ((hash self) self)
  84.     ((crawl-exhibit n)
  85.      (let ((port (standard-output)))
  86.        (format port " ~d = #x~x = #o~o = #b~b" n n n n)
  87.        (cond ((and (fx>= n 0) (fx<= n number-of-char-codes))
  88.               (format port " = (char->ascii ~s)" (ascii->char n))))
  89.        (newline port)))
  90.     ((print n port)
  91.      (let ((rdx (rt-radix *print-table*)))
  92.        (labels (((write-fx n)
  93.                (cond ((fxN= n 0)
  94.                       (write-fx (fx/ n rdx))
  95.                       (let ((c (digit->char (fx-abs (fx-rem n rdx)) rdx)))
  96.                         (write-char port c))))))
  97.          (cond ((iob? port) (vm-write-fixnum port n rdx))
  98.                ((fx= n 0) (write-char port #\0))
  99.                (else
  100.                 (if (fx< n 0) (write-char port negative-sign-char))
  101.                 (write-fx n))))))))
  102.